R Markdown file

library("tidyverse"); theme_set(theme_bw())
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ ggplot2 3.4.0      ✔ purrr   0.3.4 
## ✔ tibble  3.1.8      ✔ dplyr   1.0.10
## ✔ tidyr   1.2.1      ✔ stringr 1.4.1 
## ✔ readr   2.1.2      ✔ forcats 0.5.2 
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
library("Sleuth3")

# Tables
library("DT")
## Warning: package 'DT' was built under R version 4.2.3
library("knitr") # for kable
library("kableExtra")
## Warning: package 'kableExtra' was built under R version 4.2.3
## 
## Attaching package: 'kableExtra'
## 
## The following object is masked from 'package:dplyr':
## 
##     group_rows
library("formattable")
## Warning: package 'formattable' was built under R version 4.2.3
# Figures
library("scales")
## 
## Attaching package: 'scales'
## 
## The following objects are masked from 'package:formattable':
## 
##     comma, percent, scientific
## 
## The following object is masked from 'package:purrr':
## 
##     discard
## 
## The following object is masked from 'package:readr':
## 
##     col_factor
library("plotly")
## 
## Attaching package: 'plotly'
## 
## The following object is masked from 'package:formattable':
## 
##     style
## 
## The following object is masked from 'package:ggplot2':
## 
##     last_plot
## 
## The following object is masked from 'package:stats':
## 
##     filter
## 
## The following object is masked from 'package:graphics':
## 
##     layout
library("leaflet")
## Warning: package 'leaflet' was built under R version 4.2.3
library("gifski")
## Warning: package 'gifski' was built under R version 4.2.3

Tables

We will take a look at the diamonds data set.

dim(diamonds)
## [1] 53940    10

As we will see later, this data is too large for interactive tables and thus we will take a random sample of these data.

kable

The kable() function in the knitr package provides an easy display of tables in an HTML document.

By default, the kable function will show the entire table. So, let’s just show the first few lines.

d <- diamonds %>%
  group_by(cut) %>% # ensure we have all cuts for grouping
  sample_n(3)

Also, by default, the table looks pretty bad, so let’s add some styling.

knitr::kable(d) %>% 
  kable_styling()
carat cut color clarity depth table price x y z
0.70 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.10 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1.00 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
0.50 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1.00 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.40 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.70 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
0.30 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.40 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.30 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
1.00 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64

Formatting

d %>%
knitr::kable(
  caption = "Diamonds data", 
  align = c("rlllrrrrrr")
) %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
  scroll_box(height = "200px")
Diamonds data
carat cut color clarity depth table price x y z
0.70 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.10 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1.00 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
0.50 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1.00 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.40 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.70 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
0.30 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.40 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.30 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
1.00 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64

Grouping

groups <- table(d$cut)

d %>%
knitr::kable(
  caption = "Diamonds data", 
  align = c("rlllrrrrrr")
) %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed')) %>%
  pack_rows(
    index = setNames(groups, names(groups))
  )
Diamonds data
carat cut color clarity depth table price x y z
Fair
0.70 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.10 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1.00 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
Good
0.50 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1.00 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
Very Good
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.40 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.70 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
Premium
0.30 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.40 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.30 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
Ideal
1.00 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64

Highlighting

d %>%
  # Conditional highlighting
  mutate(
    carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
    price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
  ) %>%
  
knitr::kable(
  escape = FALSE,
  caption = "Diamonds data", 
  align = c("rlllrrrrrr")
) %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed'))
Diamonds data
carat cut color clarity depth table price x y z
0.7 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.1 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
0.5 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.4 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.7 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
0.3 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.4 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.3 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
1 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64

formattable

Another function is formattable() in the formattable package. The default table is reasonable.

d %>%
  formattable::formattable()
carat cut color clarity depth table price x y z
0.70 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.10 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1.00 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
0.50 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1.00 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.40 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.70 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
0.30 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.40 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.30 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
1.00 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64 
d %>%
  
  # Conditional highlighting
  mutate(
    carat = cell_spec(carat, "html", color = ifelse(carat > .7, "red", "black")),
    price = cell_spec(price, "html", color = ifelse(price < 5000, "blue", "black"))
  ) %>%
  
  formattable::formattable(
    list(
      # Width depends on proportion from 0 to max value
      x = color_bar("#C8102E"),    
      y = color_bar("#C8102E"),    
      z = color_bar("#C8102E"),    
      
      # Color depends on proportion from min to max value
      depth = color_tile("#CAC7A7","#524727")
    )
  )
carat cut color clarity depth table price x y z
0.7 Fair F SI2 66.4 56 1564 5.51 5.42 3.63
2.1 Fair G I1 64.6 58 6597 8.05 8.01 5.19
1 Fair E SI2 65.8 58 2948 6.28 6.16 4.09
0.5 Good G VVS2 63.8 56 1715 5.03 5.06 3.22
0.93 Good F SI2 61.3 62 3376 6.17 6.26 3.81
1 Good G VVS1 63.8 60 7134 6.35 6.31 4.04
0.31 Very Good F VS1 60.9 56 675 4.37 4.38 2.66
0.4 Very Good D SI2 61.6 59 666 4.68 4.74 2.90
0.7 Very Good E VS1 63.8 57 3177 5.61 5.65 3.59
0.3 Premium H VS1 63.0 58 675 4.28 4.23 2.68
0.4 Premium E VS1 62.4 54 1125 4.75 4.71 2.95
0.3 Premium F VVS2 61.6 58 737 4.28 4.35 2.66
1 Ideal D VS1 62.4 55 7966 6.40 6.43 4.00
0.41 Ideal F VVS1 62.0 55 1295 4.74 4.78 2.95
1.57 Ideal G VVS2 62.3 56 15144 7.48 7.41 4.64

DT

As we will see, with the pagination, datatable() provides the capability to succinctly display much larger tables. So we will use more data

set.seed(20230416)
d <- diamonds %>%
  sample_n(1000)

A basic interactive table using DT::datatable().

DT::datatable(d)

Many options can be added

Filtering

DT::datatable(d, rownames = FALSE, filter = "top")

Buttons

DT::datatable(d, rownames = FALSE, 
              extensions = "Buttons",
              options = list(
                dom = "Bfrtip",
                buttons = c("copy","csv","excel","pdf","print")
              ))

Editing

DT::datatable(d, rownames = FALSE, 
              editable = TRUE,
              extensions = "Buttons",
              options = list(
                dom = "Bfrtip",
                buttons = c("copy","csv","excel","pdf","print")
              ))

Figures

Plots

ggplotly()

Scatterplot

Here is a static plot of the diamonds data set.

d <- diamonds %>% sample_n(1000)

g <- ggplot(d, 
            aes(
              x = carat, 
              y = price,
              shape = cut,
              color = color)) + 
  geom_point() +
  scale_y_log10() + 
  scale_x_log10(breaks = scales::breaks_pretty()) 

g
## Warning: Using shapes for an ordinal variable is not advised

ggplotly(g)
## Warning: Using shapes for an ordinal variable is not advised

It seems plotly.js does not support multiple legends.

Boxplot

g <- ggplot(case0501, aes(x = Diet, y = Lifetime)) + 
  geom_boxplot() +
  coord_flip()

ggplotly(g)

Histogram

g <- ggplot(diamonds, aes(x = price)) + 
  geom_histogram(bins = 100)

ggplotly(g)

dygraphs()

Another package from constructing interactive graphics is dygraphs.

Maps

leaflet()

Example taken from here.

leaflet::leaflet() %>% 
  addTiles() %>%
  setView(-93.65, 42.0285, zoom = 17) %>%
  addPopups(
    -93.65, 42.0285,
    'Here is the <b>Department of Statistics</b>, ISU'
  )

animations

gibbs_bivariate_normal = function(theta0, n_points, rho) {
  theta = matrix(theta0, nrow=n_points, ncol=2, byrow=TRUE)
  v = sqrt(1-rho^2)
  for (i in 2:n_points) {
    theta[i,1] = rnorm(1, rho*theta[i-1,2], v)
    theta[i,2] = rnorm(1, rho*theta[i  ,1], v)
  }
  return(theta)
}

theta = gibbs_bivariate_normal(c(-3,3), n<-20, rho=rho<-0.9)
bivariate_normal_animation = function(x, rho, ask=interactive()) {
  # Create contour plot
  n.out = 101
  xx <- seq(-3, 3, length=n.out)
  grid <- expand.grid(x=xx, y=xx)
  Sigma = diag(rep(.1,2))+rho
  like <- matrix(apply(grid, 1, function(x) mvtnorm::dmvnorm(x,sigma=Sigma)),n.out,n.out)
  
  for (i in 2:nrow(x)) {
    jj = (2:i)[-(i-1)] # vector from 2:(i-1) and NULL if i=2
    for (j in 1:6) {
      plot.new()
      
      # All previous plotting
      contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3), 
              xlab=expression(theta[1]), ylab=expression(theta[2]))  
      segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
      segments(x[jj  ,1], x[jj-1,2], x[jj,1], x[jj  ,2], col="gray")
      points(x[(1:(i-1)),1], x[(1:(i-1)),2], col="red", pch=19)
      
      # New plotting
      if (j>1 & j<4) abline(h=x[i-1,2], lty=2)
      if (j>2) arrows(x[i-1,1], x[i-1,2], x[i,1], x[i-1,2], length=0.1)
      if (j>3 & j<6) abline(v=x[i,1], lty=2)
      if (j>4) arrows(x[i,1], x[i-1,2], x[i,1], x[i,2], length=0.1)
      if (j>5) points(x[i,1], x[i,2], col="red", pch=19)
      
      if (ask) readline("hit <enter>:")
    }
  }
  
  jj=2:nrow(x)
  contour(xx, xx, like, drawlabels=F, nlevels=10, xlim=c(-3,3), ylim=c(-3,3), 
          xlab=expression(theta[1]), ylab=expression(theta[2]))  
  segments(x[jj-1,1], x[jj-1,2], x[jj,1], x[jj-1,2], col="gray")
  segments(x[jj  ,1], x[jj-1,2], x[jj,1], x[jj  ,2], col="gray")
  points(x[,1], x[,2], col="red", pch=19)
}
bivariate_normal_animation(theta, rho = 0.9)

Additional resources/examples

Official:

Individuals: